home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Source Code / Visual Basic Source Code.iso / vbsource / sendsm1a / modmail.bas < prev    next >
Encoding:
BASIC Source File  |  1999-09-29  |  4.8 KB  |  181 lines
  1. Attribute VB_Name = "modMail"
  2. Option Explicit
  3.  
  4. Public LastSMTP As String
  5.  
  6. Public Declare Function GetTickCount Lib "kernel32" () As Long
  7.  
  8. '---------------------------------------------------------------------------
  9. ' AUTHOR: gh0ul
  10. '
  11. ' PROCEDURE NAME: Mail
  12. ' PURPOSE:        calls a function to initialze mail
  13. ' PARAMETERS:     SUbject, To, From, Host, Body
  14. '
  15. ' RETURNS:        nothing
  16. '
  17. '---------------------------------------------------------------------------
  18. ' DATE:  September,30 99
  19. ' TIME:  01:01
  20. '---------------------------------------------------------------------------
  21.  
  22. Sub Mail(strSubject As String, strTo As String, strFrom As String, _
  23.              strBody As String, strHost As String)
  24.              
  25.     Call InitMail(strSubject, strTo, strFrom, strBody, strHost)
  26.     
  27. End Sub
  28.  
  29. '---------------------------------------------------------------------------
  30. ' AUTHOR: gh0ul
  31. '
  32. ' PROCEDURE NAME: InitMail()
  33. ' PURPOSE:        this sub attempts to send the message.
  34. ' PARAMETERS:     same as above
  35. '
  36. ' RETURNS:        nada
  37. '
  38. '---------------------------------------------------------------------------
  39. ' DATE:  September,30 99
  40. ' TIME:  01:03
  41. '---------------------------------------------------------------------------
  42.  
  43. Sub InitMail(strSubject As String, strTo As String, strFrom As String, _
  44.              strBody As String, strHost As String)
  45.  
  46.  
  47. Test:
  48.     DoEvents
  49.     Dim Res
  50.     Debug.Print "Trying to send mail " & Timer
  51.     Res = doMail(strSubject, strTo, strFrom, strBody, strHost)
  52.     If Res = True Then GoTo Wait
  53.     If Res = False Then GoTo Test
  54.  
  55. Wait:
  56. Form1.lblStats = "Mail sent " & Timer
  57.  
  58.  
  59. End Sub
  60.  
  61. '---------------------------------------------------------------------------
  62. ' AUTHOR: gh0ul
  63. '
  64. ' PROCEDURE NAME: doMail()
  65. ' PURPOSE:        Sends the mail via winsock... connects, sends, disconnects.
  66. ' PARAMETERS:     same as above
  67. '
  68. ' RETURNS:        Boolean.... this function is called until true, else mail
  69. '                 send will fail
  70. '
  71. '---------------------------------------------------------------------------
  72. ' DATE:  September,30 99
  73. ' TIME:  01:04
  74. '---------------------------------------------------------------------------
  75.  
  76. Public Function doMail(strSubject As String, strTo As String, strFrom As String, _
  77.              strBody As String, strHost As String) As Boolean
  78.  
  79.     On Error Resume Next
  80.     Dim CTimer As Long
  81.     Dim Server As String
  82.     Dim UserName As String
  83.  
  84.     LastSMTP = ""
  85.  
  86.     Randomize Timer
  87.  
  88.     Server = strHost
  89.  
  90.     Form1.lblStats = "Trying to connect to " & Server
  91.  
  92.     With Form1.SMTP
  93.        .Close
  94.        .LocalPort = 0
  95.        .RemoteHost = Server
  96.        .RemotePort = 25  ' this usually works for e_Mail
  97.        .Connect
  98.     End With
  99.  
  100.     CTimer = Timer
  101.     Dim dbgState As Integer
  102.     dbgState = 10
  103.     Do
  104.         If Len(LastSMTP) > 1 Then GoTo SendMail
  105.         If Form1.SMTP.State <> dbgState Then
  106.           Form1.lblStats = Form1.SMTP.State
  107.             dbgState = Form1.SMTP.State
  108.         If Form1.SMTP.State = 9 Then Exit Do
  109.         End If
  110.         DoEvents
  111.  
  112.     Loop Until CTimer + 30 < Timer
  113.  
  114.     doMail = False
  115.     Form1.lblStats = "Timed Out..."
  116.     Form1.lblStats = "Last SMTP: " & LastSMTP
  117.  
  118.     Exit Function
  119.  
  120. SendMail:
  121.  
  122.     Pause 0.5
  123.  
  124.  
  125.     With Form1
  126.         .SMTP.SendData "HELO " & String(256, "A") & vbCrLf 'hide ip from old sendmail
  127.         .SMTP.SendData "MAIL FROM:" & strFrom & "@" & Form1.SMTP.LocalIP & vbCrLf
  128.         .SMTP.SendData "RCPT TO:" & strTo & vbCrLf
  129.         .SMTP.SendData "RCPT TO" & strTo & vbCrLf
  130.         .SMTP.SendData "DATA" & vbCrLf
  131.         
  132.         Pause 0.5
  133.  
  134.         .SMTP.SendData "TO: " & strTo & vbCrLf
  135.         .SMTP.SendData "FROM: " & LCase(strFrom) & "@" & Form1.SMTP.LocalIP & vbCrLf
  136.         .SMTP.SendData "Subject: " & strSubject & vbCrLf
  137.         .SMTP.SendData vbCrLf
  138.         .SMTP.SendData String(5, Chr(13)) & vbCrLf
  139.  
  140.         Pause 0.5
  141.  
  142.         .SMTP.SendData "Time Sent:    " & Time & vbCrLf & "IP Address:    " & Form1.SMTP.LocalIP & vbCrLf
  143.         .SMTP.SendData vbCrLf & strBody & vbCrLf
  144.         .SMTP.SendData vbCrLf
  145.         .SMTP.SendData "." & vbCrLf
  146.     End With
  147.     
  148.         CTimer = Timer
  149.         Form1.lblStats = "Email Sent to " & strTo
  150.         
  151.    
  152.    
  153.     Do
  154.        DoEvents
  155.     Loop Until CTimer + 20 < Timer
  156.  
  157.     With Form1.SMTP
  158.       .Close
  159.       .LocalPort = 0
  160.     End With
  161.     
  162.     doMail = True
  163.  
  164.     Form1.lblStats = "Closing Connection..."
  165. End Function
  166.  
  167.  
  168.  
  169. ' you need slight pauses when sending multiple strings of data with
  170. ' winsock. this function does that in 1000th of seconds  1000 = 1 sec
  171. Sub Pause(HowLong As Long)
  172.     '
  173.     Dim u%, Tick As Long
  174.     
  175.     Tick = GetTickCount
  176.     
  177.     Do
  178.       u% = DoEvents
  179.     Loop Until Tick + HowLong < GetTickCount
  180. End Sub
  181.